9, 10

;(use-syntax (ice-9 syncase))
(define-syntax evaluate
  (syntax-rules ()
    ((_ list)
     (eval list (interaction-environment)))))
(define (set-cadr! l v)
  (set-car! (cdr l) v))
(define (sym<->str arg)
  (if (symbol? arg)
      (symbol->string arg)
      (string->symbol arg)))
(define (strs->sym . strings)
  (sym<->str (apply string-append strings)))
(define-syntax struct-getter
  (syntax-rules ()
    ((_ name field)
     (evaluate (list 'define(list (strs->sym (sym<->str 'name) "-" (sym<->str 'field)) 'struct) '(cadr (assoc 'field (cdr struct))))))))
(define-syntax struct-setter
  (syntax-rules ()
    ((_ name field)
     (evaluate (list 'define (list (strs->sym "set-" (sym<->str 'name) "-" (sym<->str 'field) "!") 'struct 'val) '(set-cadr! (assoc 'field (cdr struct)) val))))))
(define-syntax struct-getters
  (syntax-rules ()
    ((_ name (field))
     (struct-getter name field))
    ((_ name (field fields ...))
     (begin
       (struct-getter name field)
       (struct-getters name (fields ...))))))
(define-syntax struct-setters
  (syntax-rules ()
    ((_ name (field))
     (struct-setter name field))
    ((_ name (field fields ...))
     (begin
       (struct-setter name field)
       (struct-setters name (fields ...))))))
(define-syntax struct-pred
  (syntax-rules ()
    ((_ name)
     (evaluate (list 'define (list (strs->sym (sym<->str 'name) "?") 'struct) '(and (list? struct) (symbol? (car struct)) (equal? (car struct) 'name)))))))
(define-syntax struct-record
  (syntax-rules ()
    ((_ (field))
     (list (list 'list ''field (strs->sym (sym<->str 'field) "_arg"))))
    ((_ (field fields ...))
     (append (list (list 'list ''field (strs->sym (sym<->str 'field) "_arg"))) (struct-record (fields ...))))
    ((_ name (fields ...))
     (append '('name) (struct-record (fields ...))))))
(define-syntax struct-make
  (syntax-rules ()
    ((_ name (fields ...))
     (evaluate (list 'define (list (strs->sym "make-" (sym<->str 'name)) (strs->sym (sym<->str 'fields) "_arg") ...) (append '(list) (struct-record name (fields ...))))))))
(define-syntax define-struct
  (syntax-rules ()
    ((_ name (fields ...))
     (begin
       (struct-getters name (fields ...))
       (struct-setters name (fields ...))
       (struct-pred name)
       (struct-make name (fields ...))))))

;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

;(use-syntax (ice-9 syncase))
(define-syntax define-data
  (syntax-rules ()
    ((_ type constructors)
     (define-type `type `constructors))))
(define (define-type type constructors)
  (define (define-constructor constructor)
    (eval
     `(define ,constructor
        (list ',(car constructor) ,@(cdr constructor)))
     (interaction-environment)))
  (define (define-predicate)
    (eval
     `(define (,(string->symbol (string-append (symbol->string type) "?")) ys)
        (and (list? ys) (not (null? ys)) (assoc (car ys) ',constructors) #t))
     (interaction-environment)))
  (define-predicate)
  (for-each
   define-constructor
   constructors))
(define-syntax match
  (syntax-rules ()
    ((_ xs) #f)
    ((_ xs ((shape-type args ...) expr) exprs ...)
     (or (and (list? xs) (not (null? xs)) (equal? (car xs) 'shape-type) (equal? (length (cdr xs)) (length '(args ...))) (eval (cons '(lambda (args ...) expr) (cdr xs)) (interaction-environment))) (match xs exprs ...)))))