(rnrs records syntactic)とsrfi-17の一般化されたset!

(rnrs records syntactic)とsrfi-17を組み合わせて使いたかったんだけど，どうも手動でsetterをset!しなければならないようだったので，マクロの勉強ついでにsetterをset!してくれるものを書いた．
最初は手続きで書いてdefine-record-typeの後に置くようなものを書こうとしていたんだけど，record-(accessor|mutator)が(少なくともracketだと)毎回新しい手続きを返すために，書く事ができなかった．
R6RSやsyntax-case関連についてあまりよくわかっていないので，おかしいところが多々あるかもしれない．
ろくにテストしていないのでちゃんと動くかどうかもわからない．

#!r6rs
(library (kaki records)
  (export define-record-type-with-setter
          fields mutable immutable parent protocol sealed opaque nongenerative parent-rtd)
  (import (for (rnrs base) run expand)
          (rnrs records syntactic)
          (rename (srfi :17) (set! srfi-17:set!))

          (for (rnrs syntax-case) expand)
          (for (rnrs lists) expand)
          (for (only (srfi :1) filter-map) expand)
          (for (only (kaki util) let1 if-not-let1) expand))

  (define-syntax define-record-type-with-setter
    (lambda (x)
      (syntax-case x ()
        ((k name-spec . clauses)
         (let1 record-name (let1 spec (syntax->datum #'name-spec)
                             (symbol->string
                              (if (symbol? spec)
                                  spec
                                  (car spec))))
           (define (accessor-name name)
             (string->symbol (string-append record-name "-" (symbol->string name))))
           (define (mutator-name name)
             (string->symbol (string-append record-name "-" (symbol->string name) "-set!")))
           (define (maybe-accessor&mutator spec)
             (and (pair? spec)
                  (eq? 'mutable (car spec))
                  (if (null? (cddr spec))
                      (let1 field-name (cadr spec)
                        (list (accessor-name field-name)
                              (mutator-name field-name)))
                      (cddr spec))))
           (if-not-let1 field-clause (find (lambda (clause)
                                             (eq? 'fields (car clause)))
                                           (syntax->datum #'clauses))
             #'(define-record-type name-spec . clauses)
             (let1 field-specs (cdr field-clause)
               (with-syntax ((set-setter (map (lambda (p)
                                                #`(srfi-17:set! (setter #,(datum->syntax #'k (car p)))
                                                                #,(datum->syntax #'k (cadr p))))
                                              (filter-map maybe-accessor&mutator field-specs))))
                 #'(begin
                     (define-record-type name-spec . clauses)
                     . set-setter)))))))))
  )

let1とif-not-let1の(やっつけ)実装は

  (define-syntax let1
    (syntax-rules ()
      ((_ var expr body ...)
       (let ((var expr)) body ...))))

  (define-syntax if-not-let1
    (syntax-rules ()
      ((_ var expr then else)
       (let ((var expr)) (if var else then)))))