* lisp/emacs-lisp/pcase.el (pcase-defmacro): New macro.

(pcase--macroexpand): New function.
(pcase--expand): Use it.

etc/NEWS

@@ -104,6 +104,7 @@ performance improvements when pasting large amounts of text.
 
 ** pcase
 *** New UPatterns `quote' and `app'.
+*** New UPatterns can be defined with `pcase-defmacro'.
 
 ** Lisp mode
 *** Strings after `:documentation' are highlighted as docstrings.

lisp/ChangeLog

 2014-09-22  Stefan Monnier  <monnier@iro.umontreal.ca>
 
+	* emacs-lisp/pcase.el (pcase-defmacro): New macro.
+	(pcase--macroexpand): New function.
+	(pcase--expand): Use it.
+
 	Add support for `quote' and `app'.
 	* emacs-lisp/pcase.el (pcase--app-subst-match, pcase--app-subst-rest):
 	New optimization functions.

lisp/emacs-lisp/pcase.el

@@ -284,7 +284,7 @@ of the form (UPAT EXP)."
            (main
             (pcase--u
              (mapcar (lambda (case)
-                       `((match ,val . ,(car case))
+                       `((match ,val . ,(pcase--macroexpand (car case)))
                          ,(lambda (vars)
                             (unless (memq case used-cases)
                               ;; Keep track of the cases that are used.
@@ -303,6 +303,31 @@ of the form (UPAT EXP)."
           (message "Redundant pcase pattern: %S" (car case))))
       (macroexp-let* defs main))))
 
+(defun pcase--macroexpand (pat)
+  "Expands all macro-patterns in PAT."
+  (let ((head (car-safe pat)))
+    (cond
+     ((memq head '(nil pred guard quote)) pat)
+     ((memq head '(or and)) `(,head ,@(mapcar #'pcase--macroexpand (cdr pat))))
+     ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat)))
+     ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat))))
+     (t
+      (let* ((expander (get head 'pcase-macroexpander))
+             (npat (if expander (apply expander (cdr pat)))))
+        (if (null npat)
+            (error (if expander
+                       "Unexpandable %s pattern: %S"
+                     "Unknown %s pattern: %S")
+                   head pat)
+          (pcase--macroexpand npat)))))))
+
+;;;###autoload
+(defmacro pcase-defmacro (name args &rest body)
+  "Define a pcase UPattern macro."
+  (declare (indent 2) (debug (def-name sexp def-body)) (doc-string 3))
+  `(put ',name 'pcase-macroexpander
+        (lambda ,args ,@body)))
+
 (defun pcase-codegen (code vars)
   ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding
   ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy