[plt-scheme] Tagging primitive types?

Hi,

I have a somewhat strange question. Is there any way to tag any kind of 
scheme expression e (symbol, list, numbers, vectors, etc.) with a list 
of other scheme expressions, such that e behaves just like its untagged 
version, but the tags can be mutated and retrieved at any time? (Not 
exactly a *functional* programming idea, I guess)

Examples, where the printing of tags is omitted:

(define a (tag! '(1 2 3) 'my-tag))
a ==> (1 2 3)
(list? a) ==> #t
(car a) ==> 1
(cdr a) ==> (2 3)
(tagged? a) ==> #t
(tags a) ==> (my-tag)
(tag! a 'another-tag)
(tags a) ==> (my-tag another-tag)
(define b (tag a 'third-tag))
(tags b) ==> (my-tag another-tag third-tag)
(tags a) ==> (my-tag another-tag)
(equal? a b) ==> #t
(untag a) ==> (1 2 3)
(tagged? (untag a)) ==> #f

Is that possible?

Best regards,

Erich

------- Here is my 'normal' version of tagged data, but this changes 
every object into a structure, and thus requires me to rewrite every 
accessor procedure and functions like maptree, etc. -------

(module tagged-data mzscheme
   (require (lib "list.ss"))
    (require (lib "struct.ss"))
   (require (prefix srfi1- (lib "1.ss" "srfi"))) ; lists
   (require (prefix srfi13- (lib "13.ss" "srfi"))) ; strings
   (provide (all-defined))

   (define tagged-styled-printing
     (let ((styled? #t))
       (case-lambda
         [() styled?]
         [(bool) (set! styled? bool)])))

   (define (print-tagged e port write?)
     (unless (tagged-styled-printing) (when write? (write-string 
"#<tagged:" port)))
     (cond ((and (tagged? e) (pair? (tags e)))
            (if (tagged-styled-printing) (write-char #\[ port) 
(write-char #\( port))
            ((if write? write display) (car (tags e)) port)
            (for-each
             (lambda (tag)
               (write-char #\SPACE port)
               ((if write? write display) tag port)
               )
             (cdr (tags e)))
            (if (tagged-styled-printing) (write-string "]__" port) 
(write-char #\) port))
            ((if write? write display) (data e) port))
           (else ((if write? write display) (if (tagged? e) (data e) e) 
port)))
     (unless (tagged-styled-printing) (when write? (write-string ">" 
port)))
     )

   (define-struct/properties tagged (data tags)
     ([prop:custom-write print-tagged]))

   (define (tags e)
     (if (tagged? e)
         (tagged-tags e)
         '()))

   (define (data e)
     (if (tagged? e)
         (tagged-data e)
         e))

   (define (tags! e t)
     (if (tagged? e)
         (set-tagged-tags! e t)
         (make-tagged e t)))

   (define (data! e d)
     (if (tagged? e)
         (set-tagged-data! e d)
         (make-tagged e d '())))

   (define (externalize-tagged e)
     (if (tagged? e)
         (list 'tagged (tagged-data e) (tagged-tags e))
         e))

   (define (internalize-tagged e)
     (if (and (pair? e) (equal? (car e) 'tagged))
         (make-tagged (cadr e) (caddr e))
         e))

   ;;; attach tag t to expression e
   (define (tag e t)
     (cond ((tagged? e) (make-tagged (tagged-data e) (cons t 
(tagged-tags e))))
           (else (make-tagged e (list t)))))

   ;;; tag e with arbitrary many data given in rest
   ;;; e.g. (tag* 'test 'a 'b 'c 'd) ==> [a b c d]__test
   (define (tag* e . rest)
     (let loop ((li (reverse! rest))
                (result e))
       (cond ((null? li) result)
             (else (loop (cdr li) (tag result (car li)))))))

   (define (untag e)
     (if (tagged? e)
         (tagged-data e)
         e))

   (define (has-tag? e t)
     (if (tagged? e)
         (member t (tagged-tags e))
         #f))
   )