scheme-accessors/accessors.scm

(define (push-box! place val)
  (set-box! place (cons val (unbox place))))

(define (fold kons knil lst)
  (if (null? lst)
      knil
      (kons (car lst)
	    (fold kons knil (cdr lst)))))

(define (throw-a-chunk-into span l thunk)
  (let loop ((span span) (chunk '()) (l l))
    (cond ((null? l)
	   (thunk (reverse chunk) #f))
	  ((= 0 span)
	   (thunk (reverse chunk) l))
	  (else (loop (- span 1) (cons (car l) chunk) (cdr l))))))

(define (chunks span l)
  (throw-a-chunk-into span l
		      (lambda (chunk rest)
			(if rest
			    (cons chunk (chunks span rest))
			    (list chunk)))))

(define (->string x)
  (cond ((string? x) x)
	((symbol? x) (symbol->string x))
	(else (error '->string "?" x))))
(define (symbol-append s1 s2)
  (string->symbol (string-append (->string s1) (->string s2))))
(define ^ symbol-append)

(define (string-concat ss) (fold string-append "" ss))

(define (cxr acc var) (cxr* (chunks 3 acc) var))
(define (cxr* acc var)
  (if (null? acc)
      var
      (list (string->symbol (string-append "c" (string-append (string-concat (car acc)) "r")))
	    (cxr* (cdr acc) var))))

(define (go name exp)
  (let ((accessors (box '())))
    (pretty-print
     `(define (,(symbol-append name "?") exp)
	(and . ,(let loop ((exp exp) (place '()))
		  (cond ((symbol? exp)
			 (list `(eq? ',exp ,(cxr place 'exp))))
			((pair? exp)
			 (let* ((chk (list `(pair? ,(cxr place 'exp))))
				(kar (loop (car exp) (cons "a" place)))
				(kdr (loop (cdr exp) (cons "d" place))))
			   (append chk kar kdr)))
			((null? exp)
			 (list `(null? ,(cxr place 'exp))))
			((string? exp)
			 (push-box! accessors
				    `(define (,(^ name (^ "-get-" exp)) exp)
				       ,(cxr place 'exp)))
			 '()))))))
    (for-each pretty-print (reverse (unbox accessors)))))