Apologies for the multiple postings.  I have added a number of test cases and
fixed a few bugs.  Here is the updated implementation.  Any additional test
cases are welcome.

Andre

;;;=========================================================
;;;
;;; Quasisyntax in terms of SRFI-93 syntax-case.;;;
;;; Andre van Tonder
;;;
;;;=========================================================
;;;
;;; To make nested unquote-splicing behave in a useful way,
;;; the R5RS-compatible extension of quasiquote in appendix B
;;; of the following paper is here ported to quasisyntax:
;;;
;;; Alan Bawden - Quasiquotation in Lisp
;;; http://citeseer.ist.psu.edu/bawden99quasiquotation.html
;;;
;;; The algorithm converts a quasisyntax expression to an
;;; equivalent with-syntax expression.
;;; For example:
;;;
;;; (quasisyntax (set! ,a ,b))
;;;   ==> (with-syntax ((t0 a)
;;;                     (t1 b))
;;;         (syntax (set! t0 t1)))
;;;
;;; (quasisyntax (list ,@args))
;;;   ==> (with-syntax (((t ...) args))
;;;         (syntax (list t ...)))
;;;
;;; Note that quasisyntax is expanded first, before any
;;; ellipses act.  For example:
;;;
;;; (quasisyntax (f ((b ,a) ...))
;;;   ==> (with-syntax ((t a))
;;;         (syntax (f ((b t) ...))))
;;;
;;; so that
;;;
;;; (let-syntax ((test-ellipses-over-unsyntax
;;;               (lambda (e)
;;;                 (let ((a (syntax a)))
;;;                   (with-syntax (((b ...) (syntax (1 2 3))))
;;;                     (quasisyntax
;;;                      (quote ((b ,a) ...))))))))
;;;   (test-ellipses-over-unsyntax))
;;;
;;;     ==> ((1 a) (2 a) (3 a))

(define-syntax quasisyntax
   (lambda (e)

     (define (expand-quasisyntax x)

       ;; Expand returns a syntax object of the form
       ;;    (template[t/e, ...] (replacement ...))
       ;; Here template[t/e ...] denotes the original template
       ;; with unquoted expressions e replaced by fresh
       ;; variables t, followed by the appropriate ellipses
       ;; if e is also spliced.
       ;; The second part of the return value is the list of
       ;; replacements, each of the form (t e) if e is just
       ;; unquoted, or ((t ...) e) if e is also spliced.
       ;; This will be the list of bindings of the resulting
       ;; with-syntax expression.

       (define (expand x level)
         (syntax-case x (quasisyntax unquote unquote-splicing)
           ((quasisyntax e)
            (with-syntax (((k _) x)  ; Original must be copied
                          ((rest bs) (expand (syntax e) (+ level 1))))
              (syntax
               ((k rest) bs))))
           ((unquote e)
            (= level 0)
            (with-syntax (((t) (generate-temporaries '(t))))
              (syntax (t ((t e))))))
           (((unquote e ...) . r)
            (= level 0)
            (with-syntax (((rest (b ...)) (expand (syntax r) 0))
                          ((t ...)        (generate-temporaries (syntax (e
...)))))
              (syntax
               ((t ... . rest)
                ((t e) ... b ...)))))
           (((unquote-splicing e ...) . r)
            (= level 0)
            (with-syntax (((rest (b ...)) (expand (syntax r) 0))
                          ((t ...)        (generate-temporaries (syntax (e
...)))))
              (with-syntax ((((t ...) ...) (syntax ((t (... ...)) ...))))
                (syntax
                 ((t ... ... . rest)
                  (((t ...) e) ... b ...))))))
           ((k . r)
            (and (> level 0)
                 (identifier? (syntax k))
                 (or (free-identifier=? (syntax k) (syntax unquote))
                     (free-identifier=? (syntax k) (syntax unquote-splicing))))
            (with-syntax (((rest bs) (expand (syntax r) (- level 1))))
              (syntax
               ((k . rest) bs))))
           ((h . t)
            (with-syntax (((head (b1 ...)) (expand (syntax h) level))
                          ((tail (b2 ...)) (expand (syntax t) level)))
              (syntax
               ((head . tail)
                (b1 ... b2 ...)))))
           (#(e ...)
            (with-syntax ((((e* ...) bs)
                           (expand (vector->list (syntax #(e ...))) level)))
              (syntax
               (#(e* ...) bs))))
           (other
            (syntax (other ())))))

       (with-syntax (((template bindings) (expand x 0)))
         (syntax
          (with-syntax bindings (syntax template)))))

     (syntax-case e ()
       ((k template)
        (expand-quasisyntax (syntax template))))))

;;;==========================================================================
;;;
;;; Tests:
;;;
;;;==========================================================================

(define-syntax swap!
   (lambda (e)
     (syntax-case e ()
       ((_ a b)
        (let ((a (syntax a))
              (b (syntax b)))
          (quasisyntax
           (let ((temp ,a))
             (set! ,a ,b)
             (set! ,b temp))))))))

(let ((temp 1)
       (set! 2))
   (swap! set! temp)
   (values temp set!))   ;==> 2 1

(define-syntax case
   (lambda (x)
     (syntax-case x ()
       ((_ e c1 c2 ...)
        (quasisyntax
         (let ((t e))
           ,(let f ((c1 (syntax c1)) (cmore (syntax (c2 ...))))
              (if (null? cmore)
                  (syntax-case c1 (else)
                    ((else e1 e2 ...)    (syntax (begin e1 e2 ...)))
                    (((k ...) e1 e2 ...) (syntax (if (memv t '(k ...))
                                                     (begin e1 e2 ...)))))
                  (syntax-case c1 ()
                    (((k ...) e1 e2 ...)
                     (quasisyntax
                      (if (memv t '(k ...))
                          (begin e1 e2 ...)
                          ,(f (car cmore) (cdr cmore))))))))))))))

(case 'a
   ((b c) 'no)
   ((d a) 'yes))

(define-syntax let-in-order
   (lambda (form)
     (syntax-case form ()
       ((_ ((i e) ...) e0 e1 ...)
        (let f ((ies (syntax ((i e) ...)))
                (its (syntax ())))
          (syntax-case ies ()
            (()            (quasisyntax (let ,its e0 e1 ...)))
            (((i e) . ies) (with-syntax (((t) (generate-temporaries '(t))))
                             (quasisyntax
                              (let ((t e))
                                ,(f (syntax ies)
                                    (quasisyntax
                                     ((i t) ,@its)))))))))))))

(let-in-order ((x 1)
                (y 2))
    (+ x y))                ;==> 3

(let-syntax ((test-ellipses-over-unsyntax
               (lambda (e)
                 (let ((a (syntax a)))
                   (with-syntax (((b ...) (syntax (1 2 3))))
                     (quasisyntax
                      (quote ((b ,a) ...))))))))
   (test-ellipses-over-unsyntax))

       ;==> ((1 a) (2 a) (3 a))

;; Some tests found online (Guile?)

(let-syntax ((test
               (lambda (_)
                 (quasisyntax
                  '(list ,(+ 1 2) 4)))))
   (test))
                                         ;==> (list 3 4)

(let-syntax ((test
               (lambda (_)
                 (let ((name (syntax a)))
                   (quasisyntax '(list ,name ',name))))))
   (test))
                                         ;==> (list a 'a)

(let-syntax ((test
               (lambda (_)
                 (quasisyntax '(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)))))
   (test))
                                         ;==> (a 3 4 5 6 b)

(let-syntax ((test
               (lambda (_)
                 (quasisyntax '((foo ,(- 10 3)) ,@(cdr '(5)) . ,(car '(7)))))))
   (test))
                                         ;==> ((foo 7) . 7)

(let-syntax ((test
               (lambda (_)
                 (quasisyntax '#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8)))))
   (test))
                                         ;==> #6(10 5 2 4 3 8)

(let-syntax ((test
               (lambda (_)
                 (quasisyntax ,(+ 2 3)))))
   (test))
                                         ;==> 5

(let-syntax ((test
               (lambda (_)
                 (quasisyntax
                  '(a (quasisyntax (b ,(+ 1 2) ,(foo ,(+ 1 3) d) e)) f)))))
   (test))
                                         ;==> (a (quasisyntax (b ,(+ 1 2) ,(foo 4
d) e)) f)

(let-syntax ((test
               (lambda (_)
                 (let ((name1 #'x) (name2 #'y))
                   (quasisyntax
                    '(a (quasisyntax (b ,,name1 ,#',name2 d)) e))))))
   (test))
                                         ;==> (a (quasisyntax (b ,x ,#'y d)) e)

;; Bawden's extensions:

(let-syntax ((test
               (lambda (_)
                 (quasisyntax '(a (unquote 1 2) b)))))
   (test))
                                         ;==> (a 1 2 b)

(let-syntax ((test
               (lambda (_)
                 (quasisyntax '(a (unquote-splicing '(1 2) '(3 4)) b)))))
   (test))
                                         ;==> (a 1 2 3 4 b)

(let-syntax ((test
               (lambda (_)
                 (let ((x #'(a b c)))
                   (quasisyntax '(quasisyntax (,,x ,@,x ,,@x ,@,@x)))))))
   (test))

         ;==> (quasisyntax (,(a b c) ,@(a b c) (unquote a b c) (unquote-splicing
a b c)))
         ;    which is equivalent to
         ;    (quasisyntax (,(a b c) ,@(a b c) ,a ,b ,c ,@a ,@b ,@c)
         ;    in the Bawden prescription