* Added define-condition-type macro.

scheme/makefile.ss

@@ -148,6 +148,7 @@
     [nongenerative       (macro . nongenerative)]
     [parent-rtd          (macro . parent-rtd)]
     [define-record-type  (macro . define-record-type)]
+    [define-condition-type  (macro . define-condition-type)]
     [&condition                ($core-rtd . (&condition-rtd &condition-rcd))]
     [&message                  ($core-rtd . (&message-rtd &message-rcd))]
     [&warning                  ($core-rtd . (&warning-rtd &warning-rcd ))]

scheme/psyntax.expander.ss

@@ -1579,6 +1579,41 @@
         [(ctxt namespec clause* ...)
          (do-define-record ctxt namespec clause*)])))
   
+  (define define-condition-type-macro
+    (lambda (x)
+      (define (mkname name suffix)
+        (datum->syntax name 
+           (string->symbol 
+             (string-append 
+               (symbol->string (syntax->datum name))
+               suffix))))
+      (syntax-match x ()
+        [(ctxt name super constructor predicate (field* accessor*) ...)
+         (and (id? name) 
+              (id? super)
+              (id? constructor)
+              (id? predicate)
+              (for-all id? field*)
+              (for-all id? accessor*))
+         (let ([aux-accessor* (map (lambda (x) (gensym)) accessor*)])
+           (bless
+              `(begin
+                 (define-record-type (,name ,constructor ,(gensym))
+                    (parent ,super)
+                    (fields ,@(map (lambda (field aux) 
+                                     `(immutable ,field ,aux))
+                                   field* aux-accessor*))
+                    (nongenerative)
+                    (sealed #f) (opaque #f))
+                 (define ,predicate (condition-predicate
+                                      (record-type-descriptor ,name)))
+                 ,@(map 
+                     (lambda (accessor aux)
+                        `(define ,accessor 
+                           (condition-accessor
+                             (record-type-descriptor ,name) ,aux)))
+                     accessor* aux-accessor*))))])))
+  
   (define incorrect-usage-macro
     (lambda (e) (stx-error e "incorrect usage of auxilary keyword")))
   
@@ -2117,7 +2152,8 @@
            ((endianness)        endianness-macro)
            ((trace-lambda)      trace-lambda-macro)
            ((trace-define)      trace-define-macro)
-           ((eol-style)         
+           ((define-condition-type)      define-condition-type-macro)
+           ((eol-style)
             (lambda (x) 
               (symbol-macro x '(none lf cr crlf nel crnel ls))))
            ((error-handling-mode)         

scheme/todo-r6rs.ss

@@ -423,7 +423,7 @@
     [condition-message                          C co]
     [condition-predicate                        C co]
     [condition-who                              C co]
-    [define-condition-type                      S co]
+    [define-condition-type                      C co]
     [&error                                     C co]
     [error?                                     C co]
     [&implementation-restriction                C co]