Generic copy and record copy

generic-copy.scm

(import (scheme base))

;; copier
(define *copier-table* '())
(define (generic-copy obj)
  (cond ((assoc obj *copier-table* (lambda (x p) (p x))) =>
         (lambda (s) ((cdr s) obj)))
        ;; shallow copy, sort of
        (else obj)))
(define (register-copier! pred copier)
  (set! *copier-table* (cons (cons pred copier) *copier-table*)))

;; how to use
(register-copier! pair? list-copy)
(register-copier! vector? vector-copy)
(register-copier! string? string-copy)
(register-copier! bytevector? bytevector-copy)

record-copy.scm

(import (scheme base))

(define-syntax define-record-copier
  (syntax-rules ()
    ((define-record-copier "emit" name (ctr f ...) (acc ...) ((a m) ...))
     ;; now we have all information
     (define (name obj)
       (let ((c (ctr (acc obj) ...)))
         ;; mutate if mutators are defined, then we use it.
         ;; to make it simple, we do for all mutator. so some
         ;; of them are just useless.
         ;; FIXME this is not efficient.
         (m c (a obj)) ...
         c)))
    ((_ "mutator" name ctr accessor mutator ())
     (define-record-copier "emit" name ctr accessor mutator))
    ((_ "mutator" name ctr accessor (mutator* ...) ((f a) rest ...))
     (define-record-copier "mutator" name ctr accessor
       (mutator* ...) (rest ...)))
    ((_ "mutator" name ctr accessor (mutator* ...) ((f a m) rest ...))
     (define-record-copier "mutator" name ctr accessor
       (mutator* ... (a m)) (rest ...)))
    ((_ "collect" name ctr (acc ...) () (def* ...))
     (define-record-copier "mutator" name ctr (acc ...) ()(def* ...)))
    ((_ "collect" name ctr (acc ...) (field field* ...) (def* ...))
     (begin
       ;; this part is not R7RS portable since 'foo' doesn't have to be
       ;; renamed (right?). so some of implementation may raise an error
       ;; of redefinition (e.g. Foment)
       ;; however we can't use letrec-syntax because it creates a scope.
       ;; sucks...
       (define-syntax foo
         (syntax-rules (field)
           ((_ ?n ?c
               ((field ac . ignore) rest (... ...))
               (next (... ...))
               (src  (... ...)))
            (define-record-copier "collect" ?n ?c (acc ... ac)
              (next (... ...)) (src (... ...))))
           ((_ ?n ?c (_ rest (... ...)) (next (... ...)) (src (... ...)))
            (foo ?n ?c (rest (... ...)) (next (... ...)) (src (... ...))))))
       (foo name ctr (def* ...) (field* ...) (def* ...))))
    ((_ name ctr (ctr-field* ...) (field-def* ...))
     (define-record-copier "collect" name ctr
       () ;; accessor
       (ctr-field* ...)
       (field-def* ...)))))

(define-syntax define-record-type/copy
  (syntax-rules ()
    ((_ name (ctr field* ...) pred copier field-def* ...)
     (begin
       (define-record-type name (ctr field* ...) pred
         field-def* ...)
       (define-record-copier copier (ctr field* ...)
         (field* ...) (field-def* ...))))))

test.scm

;; load other 2 files
(import (scheme base) (scheme write))

(define-record-type/copy pare (kons a d) pare? pare-copy
   (a kar)
   (d kdr)
   (s pare-src pare-src-set!))

;; if you want
#;(define-record-type/copy reverse-pare (kons d a) pare? pare-copy
   (a kar)
   (d kdr)
   (s pare-src pare-src-set!))

(define (print . args) (for-each display args) (newline))
(let ((p (kons 'a 'b)))
  (pare-src-set! p '(src))
  (let ((c (pare-copy p)))
    (print (kar c))
    (print (kdr c))
    (print (pare-src c))))

(register-copier! pare? pare-copy)
(let ((p (kons 'a 'b)))
  (pare-src-set! p '(src))
  (let ((c (generic-copy p)))
    (print (kar c))
    (print (kdr c))
    (print (pare-src c))))