Structure-Preserving Copy

 left top 
(define (copy-list-2 l)
  (let ((tag (list 'BEEN-HERE-DONE-THAT)))
    (define (copy l)
      (cond ((null? l) '())
	    ((and (pair? l) (not (eq? (car l) tag)))
	     (let ((the-car (car l))
		   (the-cdr (cdr l))
		   (result (cons 0 0)))
	       (set-car! l tag)
	       (set-cdr! l result)
	       (set-car! result (copy the-car))
	       (set-cdr! result (copy the-cdr))
	       result))
	    ((pair? l) (cdr l))
	    (else l)))
    (copy l)))

(define z (copy-list-2 y))
z                      ; ((a b c) a b c)
(eq? (car z) (cdr z))  ; #T

(define x '(a b c))
(set-cdr! x x)
(define y (copy-list-2 x))
(eq? y (cdr y))       ; #T
Jim Miller W3C